home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / SHELLS / SZ2 / GMISC.IMP < prev    next >
Text File  |  1992-08-31  |  11KB  |  341 lines
  1.    {*******************************************************************
  2.  
  3.    GMISC.IMP
  4.  
  5.    *******************************************************************}
  6.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  7.  
  8.    DRIVE
  9.  
  10.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  11.    {===================================================================
  12.  
  13.    Use DOS "Parse Filename" to validate drive number.
  14.    Does not access the drive.
  15.    Does not correct for "phantom" floppy drives.
  16.  
  17.    ===================================================================}
  18. function IsDosDrive ( DriveNum : byte ) : boolean ;
  19. var
  20.    FCB                       : array [ 1 .. 36 ] of byte ;
  21.    FileName                  : array [ 1 .. 3 ] of char ;
  22.    R                         : registers ;
  23. begin
  24.    IsDosDrive                := FALSE ;
  25.    if DriveNum < 1 then EXIT ;
  26.    if DriveNum > 26 then EXIT ;
  27.    fillchar ( FCB, sizeof ( FCB ), 0 ) ;
  28.    FileName                  := 'x:'#0 ;
  29.    FileName [ 1 ]            := Chr ( DriveNum + 64 ) ;
  30.    with R do
  31.    begin
  32.       AH                     := $29 ;
  33.       AL                     := $00 ;
  34.       DS                     := seg ( FileName ) ;
  35.       SI                     := ofs ( FileName ) ;
  36.       ES                     := seg ( FCB ) ;
  37.       DI                     := ofs ( FCB ) ;
  38.       MsDos ( R ) ;
  39.       if AL = $FF then EXIT ;
  40.    end ;
  41.    IsDosDrive                := TRUE ;
  42. end ;
  43.    {===================================================================
  44.                                                                DOS 3.1+
  45.    IOCTL:  Check if block device is remote.
  46.    NOTE:  DOS returns TRUE, even if the disk number is invalid.
  47.           Use program logic or "IsDosDrive" to avoid invalid disks.
  48.    ===================================================================}
  49. function IsRemote ( DriveNum : byte ) : boolean ;
  50. var
  51.    Regs                      : registers ;
  52. begin
  53.    IsRemote                  := FALSE ;
  54.    Regs.AH                   := $44 ;
  55.    Regs.AL                   := $09 ;
  56.    Regs.BL                   := DriveNum ;
  57.    Regs.DX                   := 0 ;
  58.    MsDos ( Regs ) ;
  59.    if Regs.Flags and FCarry = 0 then
  60.       if ( Regs.DX and $1000 ) <> 0 then   { Bit 12, 0=local 1=remote }
  61.          IsRemote            := TRUE ;
  62. end ;
  63.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  64.  
  65.    NETWORK
  66.  
  67.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  68.    {===================================================================
  69.  
  70.    16-character machine name; blank if not on net              DOS 3.0+
  71.  
  72.    ===================================================================}
  73. function NetMachineName      : string ;
  74. var
  75.    S                         : string ;
  76.    Regs                      : registers ;
  77. begin
  78.    NetMachineName            := '' ;
  79.    FillChar ( S , SizeOf ( S ) , #32 ) ;
  80.    S [ 0 ]                   := #16 ;
  81.    S                         := S + #0 ;
  82.    Regs.AX                   := $5E00 ;
  83.    Regs.DS                   := seg ( S ) ;
  84.    Regs.DX                   := ofs ( S ) + 1 ;
  85.    Regs.CL                   := 0 ;
  86.    Regs.CH                   := 0 ;
  87.    MsDos ( Dos.Registers ( regs ) ) ;
  88.    if Regs.CH = 0 then EXIT ;                     { Name not defined }
  89.    if Regs.Flags and FCarry <> 0 then EXIT ;                 { Error }
  90.    while S [ length ( S ) ]= #0 do
  91.       delete ( S , length ( S ) , 1 ) ;                   { trim NUL }
  92.    while S [ length ( S ) ] = #32 do
  93.       delete ( S , length ( S ) , 1 ) ;                 { trim space }
  94.    NetMachineName            := S ;
  95. end;
  96.    {===================================================================
  97.  
  98.    Return "0" for stand-alone, or up to 8 character name on network.
  99.  
  100.    ===================================================================}
  101. function PcName              : string ;
  102. var
  103.    S                         : string ;
  104. begin
  105.    S                         := NetMachineName ;
  106.    if length ( S ) > 8 then
  107.       S [ 0 ]                := #8 ;
  108.    if S = '' then
  109.       S                      := '0' ;
  110.    PcName                    := S ;
  111. end ;
  112.    {===================================================================
  113.  
  114.    SOUND - for past begin/end of file.
  115.  
  116.    ===================================================================}
  117. procedure Buzz ;
  118. begin
  119.    sound ( 220 ) ;
  120.    delay ( 200 ) ;
  121.    nosound ;
  122. end ;
  123.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  124.  
  125.    MEMORY
  126.  
  127.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  128.    {===================================================================
  129.  
  130.    ADDRESS - Return the address in bytes...
  131.  
  132.    ===================================================================}
  133. function Address ( VAR A ) : longint ;
  134. var
  135.    L                         : longint ;
  136. begin
  137.    L                         := seg ( A ) ;
  138.    L                         := L * 16 ;
  139.    inc ( L , ofs ( A ) ) ;
  140.    Address                   := L ;
  141. end ;
  142.    {===================================================================
  143.  
  144.    TRAPPED - Memory deallocated below "HeapPtr"
  145.    
  146.    ===================================================================}
  147. function HeapTrapped : longint ;
  148. begin
  149.    HeapTrapped               := MemAvail - MaxAvail ;
  150. end ;
  151.    {===================================================================
  152.  
  153.    USED - Amount of allocated memory
  154.    
  155.    ===================================================================}
  156. function HeapUsed : longint ;
  157. begin
  158.    HeapUsed                  := Address ( HeapPtr^ ) -
  159.                                 Address ( HeapOrg^ ) -
  160.                                 HeapTrapped ;
  161. end ;
  162.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  163.  
  164.    REDIRECTION
  165.  
  166.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  167.    {===================================================================
  168.  
  169.    Return TRUE if handle (0=input, 1=output) is console device
  170.  
  171.    ===================================================================}
  172. function IsConsole ( Handle : word ) : boolean ;
  173. var
  174.    Regs                      : Registers ;
  175. begin
  176.    with Regs do
  177.    begin
  178.       AX                     := $4400 ;
  179.       BX                     := Handle ;
  180.       MsDos ( Regs ) ;
  181.       if ( DX and $80 ) = 0 then
  182.          IsConsole           := FALSE
  183.       else
  184.          IsConsole           := ( DX and $02 <> 0 ) or
  185.                                 ( DX and $01 <> 0 ) ;
  186.    end;
  187. end ;
  188.    {===================================================================
  189.  
  190.    Return TRUE if
  191.    1.  Input was redirected from the command-line.
  192.    2.  The program has redirected input internally.
  193.  
  194.    ===================================================================}
  195. function IsInputRedirected : boolean ;
  196. begin
  197.    IsInputRedirected         := not IsConsole ( DOS.TextRec ( Input ).Handle ) ;
  198. end ;
  199.    {===================================================================
  200.  
  201.    Return TRUE if
  202.    1.  Output was redirected from the command-line.
  203.    2.  The program has redirected output internally.
  204.  
  205.    ===================================================================}
  206. function IsOutputRedirected : boolean ;
  207. begin
  208.    IsOutputRedirected        := not IsConsole ( DOS.TextRec ( Output ).Handle ) ;
  209. end ;
  210.    {===================================================================
  211.  
  212.    Reset "input" as text device.
  213.  
  214.    ===================================================================}
  215. function RedirectInputTo ( S : string ) : boolean ;
  216. begin
  217.    RedirectInputTo           := FALSE ;
  218. {$I-}
  219.    Assign ( input , S ) ;
  220.    if IOresult <> 0 then EXIT ;
  221.    Reset ( input ) ;
  222.    if IOresult <> 0 then EXIT ;
  223. {$I+}
  224.    RedirectInputTo           := TRUE ;
  225. end ;
  226.    {===================================================================
  227.  
  228.    Appends to "output" as text device.
  229.  
  230.    ===================================================================}
  231. function RedirectOutputTo ( S : string ) : boolean ;
  232. begin
  233.    RedirectOutputTo          := FALSE ;
  234. {$I-}
  235.    close ( output ) ;
  236.    if IOresult <> 0 then EXIT ;
  237.    Assign  ( output , S ) ;
  238.    if IOresult <> 0 then EXIT ;
  239.    append ( output ) ;
  240.    if IOresult <> 0 then
  241.       rewrite ( output ) ;
  242.    if IOresult <> 0 then EXIT ;
  243. {$I+}
  244.    RedirectOutputTo          := TRUE ;
  245.    CRT.DirectVideo           := FALSE ;         { DesqView/syntax msg }
  246. end ;
  247.    {===================================================================
  248.  
  249.    Reassign input to CRT routines.
  250.  
  251.    ===================================================================}
  252. function CancelRedirectInput : boolean ;
  253. begin
  254.    CancelRedirectInput       := FALSE ;
  255. {$I-}
  256.    Flush ( input ) ;
  257.    if IOresult <> 0 then EXIT ;
  258.    Close ( input ) ;
  259.    if IOresult <> 0 then EXIT ;
  260.    AssignCrt ( input )  ;
  261.    if IOresult <> 0 then EXIT ;
  262.    reset   ( input ) ;
  263.    if IOresult <> 0 then EXIT ;
  264. {$I+}
  265.    CancelRedirectInput       := TRUE ;
  266. end ;
  267.    {===================================================================
  268.  
  269.    Reassign output to CRT routines.
  270.  
  271.    ===================================================================}
  272. function CancelRedirectOutput : boolean ;
  273. begin
  274.    CancelRedirectOutput      := FALSE ;
  275. {$I-}
  276.    Flush ( output ) ;
  277.    if IOresult <> 0 then EXIT ;
  278.    Close ( output ) ;
  279.    if IOresult <> 0 then EXIT ;
  280.    AssignCrt ( output ) ;
  281.    if IOresult <> 0 then EXIT ;
  282.    rewrite ( output ) ;
  283.    if IOresult <> 0 then EXIT ;
  284. {$I+}
  285.    CancelRedirectOutput      := TRUE ;
  286.    CRT.DirectVideo           := TRUE ;          { DesqView/syntax msg }
  287. end ;
  288.    {===================================================================
  289.  
  290.    CHDIR change
  291.  
  292.    ===================================================================}
  293. function CD ( S : string ) : boolean ;
  294. begin
  295.    S                         := FExpand ( S ) ;
  296.    while ( S [ length ( S ) ] = '\' ) and
  297.          ( length ( S ) > 3 ) do
  298.          dec ( S[0] ) ;
  299. {$I-}
  300.    ChDir ( S ) ;
  301. {$I+}
  302.    CD                        := IOResult = 0 ;
  303. end ;
  304.    {===================================================================
  305.  
  306.    MD/MKDIR - with error check.
  307.  
  308.    ===================================================================}
  309. function MD ( S : string ) : boolean ;
  310. begin
  311.    S                         := Fexpand ( S ) ;
  312.    while ( S [ length ( S ) ] = '\' ) and
  313.          ( length ( S ) > 3 ) do
  314.          dec ( S[0] ) ;
  315.    if DirExist ( S ) then
  316.    begin
  317.       MD                     := TRUE ;
  318.       EXIT ;
  319.    end ;
  320. {$I-}
  321.    MkDir ( S ) ;
  322. {$I+}
  323.    MD                        := IOResult = 0 ;
  324. end ;
  325.    {===================================================================
  326.  
  327.    RD/RMDIR - with error check.
  328.  
  329.    ===================================================================}
  330. function RD ( S : string ) : boolean ;
  331. begin
  332.    S                         := Fexpand ( S ) ;
  333.    while ( S [ length ( S ) ] = '\' ) and
  334.          ( length ( S ) > 3 ) do
  335.          dec ( S[0] ) ;
  336. {$I-}
  337.    RmDir ( S ) ;
  338. {$I+}
  339.    RD                        := IOResult = 0 ;
  340. end ;
  341.